perm filename BMSTF.F4[P11,LCS] blob
sn#581882 filedate 1981-04-28 generic text, type T, neo UTF8
SUBROUTINE BMSTF
IMPLICIT INTEGER(A-Q,S-Z)
REAL DISX,HGT,POS,CENTR,HGT1
COMMON/STF/RSTFAC(0/7),RSTJ2/MIN/MINI,RMINI /DL/RSIZ
COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20)/BM/RA,RC,RJY
COMMON/POSI/STFF(0/7),JJ2,POS/PLTR/PLT,RHT,DIS
COMMON/ALF/QQ(3),RST7,RST18,R3Q,JY,RD,RX,RW,RJX,RJ,L,K,
1 RJA,YY,DISX,HGT,RZ,INP(53)
EQUIVALENCE (J3,JQ(1)),(J4,JQ(2)),(J5,JQ(3)),(R5,RJQ(3))
1,(R6,RJQ(4)),(J7,JQ(5)),(J8,JQ(6)),(J9,JQ(7)),(J10,JQ(8))
1,(J11,JQ(9)),(J6,JQ(4)),(R9,RJQ(7)),(R8,RJQ(6)),(R3,RJQ(1))
1,(R7,RJQ(5)),(R4,RJQ(2)),(R10,RJQ(8)),(RX3,RJQ(20)),(R11,RJQ(9))
DATA R14/14.54/,RTF/3.0/,RHGT/48.0/,RBM/.83/
C RDBR IS SPACER FOR DBL BAR. TO COMPENSATE FOR NOTE #3 COMING AT POS=0
JJ8=0
IF(J8.GE.0)GO TO 99
IF(J8.LE.-10)GO TO 99
C FOR PARTIAL BEAMS
C*** TYPE R8=-1 OR R9=-1 TO PUT R3 INTO R8 OR R6 INTO R9
C GET MS[NEWNPROCESSED POS. OF R3. PUT IT IN R8
R8=RX3
J8=R8
IF(J8.EQ.0)J8=1
99 IF(J9.GE.0)GO TO 100
IF(R7.LT.0)GO TO 100
C TREMOLO POS. IN R9
IF(J9.GE.0)GO TO 100
R9=R6
RR6=R6
100 R3Q=R3
C NEXT IS FOR BEAMS
RMINI=RSTJ2
RX=RSTJ2*16.092
JRVRS=0
IF(J10.LT.10)GO TO 101
JRVRS=J10/10
C 1=LENGTHEN LEFT SIDE, 2=RIGHT, 3=BOTH
J10=J10-JRVRS*10
C VERT DISPLACEMENT MUST BE LESS THAN 10
R10=J10
101 JJ7=J7
R6=RHORZ(R6)
IF(J8.GE.0)GO TO 88
IF(R9.NE.0)GO TO 88
CC IF(R9.NE.0)GO TO 91
CALL PBEAM
GO TO 1
CC91 JJ8=-J8
88 IF(J7.LT.0)GO TO 204
IF(J10.EQ.0.AND.R9.GT.0)GO TO 1
C R8=0 AND R9=NUM -- PUTS NUMBER OUTSIDE BEAM(FOR TRIPLET
204 IF(R9.NE.0)R9=RHORZ(R9)
IF(J7.GE.0)GO TO 201
CALL TREM(RH)
GO TO 1
C NEXT FOR INNER, PARTIAL BEAMS
201 IF(J8.EQ.0)GO TO 1
IF(J8.GT.0)R8=RHORZ(R8)
C FIND TRUE HORIZONTAL POSITION IN PIXELS
JJ10=J10/10
C J10/10 =0 OR 1 OR 2 R10 NOW = DISPLACEMENT
R10=J10-JJ10*10
IF(JJ10.NE.0)GO TO 22
J10=J10+10
GO TO 4
22 IF(JJ10.EQ.2)GO TO 3
2 RH=R9+RX
GO TO 1
3 R8=R9-RX
C 10=SHRT PARTIAL LFT↑RT., 20=RT.↑LFT, 30=TO POS IN P8
4 RH=R8
C LEFT INNER POS.
1 IF(IABS(J4).GE.80)RMINI=.6*RSTJ2
RJ=RMINI*11.
RW=RMINI*RHGT
C DIST. UP OR DOWN FROM NOTE HEAD.
RJA=R10*RJ
C DISPLACEMENT
RD=R9
C POSITION 3
RJX=CENTR-RW+RJA
C FINAL HEIGHT OF LEFT SIDE NEG R7=TREMOLO
RX=MOD(J7,10)
JJ2=J7-20
RA=R6
C HORIZANTAL DIST.
RJY=(7.*R5-18.)*RSTJ2+RJA+POS-RW
C VERTICAL POS OF RIGHT SIDE.
RW=R14*RMINI
RY=1.
IF(PLT.GE.0)GO TO 197
IF(RSIZ.GE.2.)RY=2.
RY=RY/(RSTJ2*RSIZ)
C USE ONLY EVERY OTHER LINE FOR BEAMS IF SIZ≥2. (VCLIP FILLS IT IN.)
197 IF(J7.LT.20)CALL STEMUP(RY,RH)
C NO CALL IF STEMS ARE DOWN
98 RSTJ2=RSTJ2*RBM
C RBM BRINGS LINES OF BEAMS CLOSER TOGETHER. (=.83)
RJJ2=JJ2
IF(JRVRS.EQ.0)GO TO 219
X=RW
C HORIZ. SIZE OF A NOTE
IF(J7.LT.20)X=-X
C CHECK ON STEM DIR. OF BEAM DISPL=-DISPL IF TO LEFT
IF(JRVRS.EQ.3)GO TO 19
IF(JRVRS.NE.1)GO TO 119
C 1 PUSH LEFT, 2 PUSH RIGHT, 3=BOTH
19 R3Q=R3Q+X
IF(JRVRS.EQ.1)GO TO 219
C IF 3, THEN DO NEXT ALSO
X=-X
119 RA=X
219 IF(RJJ2.GT.RX)GO TO 94
IF(J10.GE.10)GO TO 7
IF(J8.EQ.0)GO TO 94
R3=RW
IF(J9.EQ.0)GO TO 292
IF(J8.GE.20)GO TO 193
293 RX=R3Q-RD
GO TO 194
7 RHX=RH-R3Q
R3=RD-R3Q
GO TO 292
193 RX=RD-RA
194 R3=ABS(RX)
292 DISX=ABS(R3Q-RA)
HGT=RJX-RJY
IF(J10.GE.10)HGT1=HGT*(RH-R3Q)/DISX
R3=R3/DISX
195 HGT=HGT*R3
JJ8=J8
J8=0
IF(J10.GE.10)GO TO 8
L=JJ8/10
IF(L.EQ.1)GO TO 95
C BEAM LFT=1, RT=2 (PARAM 8=10 OR 20)
R3Q=RD
RJX=RJY+HGT
GO TO 94
8 R3Q=RH
RJY=RJX-HGT
RJX=RJX-HGT1
GO TO 295
95 RJY=RJX-HGT
295 RA=RD
94 IF(PLT.GE.0)GO TO 930
C SKIP NEXT FOR DPY
L=7.5*RMINI*RSIZ
C MAKES CORRECT THICKNESS ON PLOTTER.
IF(RSIZ.GE.2.0)L=L/2
C HALF AS MANY LINES.
930 RC=0
C MINI LINES HAVE .2 SMALLER BEAMS. MAYBE CHANGE THIS??
CALL LINES(R3Q,RJX,3)
DO 941 K=1,L
CALL BMS
IF(PLT.GE.0)GO TO 940
RC=RC+RY
C FOR THICKENING.
CALL BMS
CALL EXCH(RA,R3Q)
941 CALL EXCH(RJY,RJX)
CALL BMS
940 JJ2=JJ2-1
IF(JJ2.LE.0)GO TO 942
C IF P7=10 OR 20 ONE BEAM WILL APPEAR.
RJY=RJY+RJ
RJX=RJX+RJ
GO TO 930
942 IF(JJ8.NE.0)RETURN
IF(J9.LE.0)RETURN
IF(R10.GE.30)RETURN
IF(J7.LT.0)RETURN
C FOR NUMBERS OUTSIDE BEAMS
RD=-10.
IF(R7.LT.20)RD=8.3
J3=R3Q+(RA-R3Q)/2.
R6=.875* RMINI
C R6 NOW = 0.875 (SIZE OF NUM.)
IF(J4.LT.80)GO TO 943
RD=RD*.7
IF(RD)RD=RD-RBM
R6=0.6
RSTJ2=RSTJ2/RBM
943 RSTJ2=RMINI
R7=1
C ITALICS
R4=R4+(R5-R4)/2.+RD
R11=0
CALL MAKNUM(R9)
END